home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / dsssl.el.z / dsssl.el
Encoding:
Text File  |  1998-05-21  |  14.4 KB  |  493 lines
  1. ;;; dsssl.el --- DSSSL parser
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/17 14:07:55
  4. ;; Version: 1.16
  5. ;; Keywords: 
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1996, 1997 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1997 by Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is part of GNU Emacs.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (require 'cl)
  30. (require 'dsssl-flow)
  31.  
  32. (if (not (fboundp 'cl-copy-hashtable))
  33.     (defun cl-copy-hashtable (h)
  34.       (let ((new (make-hash-table)))
  35.     (cl-maphash (function (lambda (k v) (cl-puthash k v new))) h)
  36.     new)))
  37.  
  38. (defconst dsssl-builtin-functions
  39.   '(not boolean\?  case equal\?  null\?  list\?  list length append
  40.     reverse list-tail list-ref member symbol\?  keyword\?  quantity\?
  41.     number\?  real\?  integer\?  = < > <= >= + * - / max min abs quotient
  42.     modulo remainder floor ceiling truncate round number->string
  43.     string->number char\?  char=\?  char-property string\?  string
  44.     string-length string-ref string=\?  substring string-append
  45.     procedure\?  apply external-procedure make time time->string quote
  46.     char-downcase identity error let)
  47.   "A list of all the builtin DSSSL functions that we support.")
  48.  
  49. (defsubst dsssl-check-args (args expected)
  50.   ;; Signal an error if we don't have the expected # of arguments
  51.   (or (= (length args) expected)
  52.       (error "Wrong # arguments (expected %d): %d" expected (length args))))
  53.  
  54. (defsubst dsssl-min-args (args min)
  55.   (or (>= (length args) min)
  56.       (error "Wrong # arguments (expected at least %d): %d" min
  57.          (length args))))
  58.  
  59. (defun dsssl-call-function (func args)
  60.   (declare (special defines units))
  61.   (let ((old-defines nil)
  62.     (old-units nil)
  63.     (func-args (nth 1 func))
  64.     (real-func (nth 2 func))
  65.     (retval nil))
  66.     ;; Make sure we got the right # of arguments
  67.     (dsssl-check-args args (length func-args))
  68.  
  69.     ;; make sure we evaluate all the arguments in the old environment
  70.     (setq args (mapcar 'dsssl-eval args))
  71.  
  72.     ;; Save the old environment
  73.     (setq old-defines (cl-copy-hashtable defines)
  74.       old-units (cl-copy-hashtable units))
  75.     
  76.     ;; Create the function's environment
  77.     (while func-args
  78.       (cl-puthash (car func-args) (car args) defines)
  79.       (setq func-args (cdr func-args)
  80.         args (cdr args)))
  81.  
  82.     ;; Now evaluate the function body, returning the value of the last one
  83.     (while real-func
  84.       (setq retval (dsssl-eval (car real-func))
  85.         real-func (cdr real-func)))
  86.  
  87.     ;; Restore the previous environment
  88.     (setq defines old-defines
  89.       units old-units)
  90.  
  91.     ;; And we are out of here baby!
  92.     retval))
  93.  
  94. (defun dsssl-eval (form)
  95.   ;; We expect to have a 'defines' and 'units' hashtable floating around
  96.   ;; from higher up the call stack.
  97.   (declare (special defines units))
  98.   (cond
  99.    ((consp form)            ; A function call
  100.     (let ((func (car form))
  101.       (args (cdr form)))
  102.       (case func
  103.     (cons
  104.      (dsssl-check-args args 2)
  105.      (cons (dsssl-eval (pop args)) (dsssl-eval (pop args))))
  106.     (cdr
  107.      (dsssl-check-args args 1)
  108.      (cdr (dsssl-eval (pop args))))
  109.     (car
  110.      (dsssl-check-args args 1)
  111.      (car (dsssl-eval (pop args))))
  112.     (not
  113.      (dsssl-check-args args 1)
  114.      (not (dsssl-eval (car args))))
  115.     (boolean\?
  116.      (dsssl-check-args args 1)
  117.      (and (symbolp (car args))
  118.           (memq (car args) '(\#f \#t))))
  119.     (if
  120.      (dsssl-min-args args 2)
  121.      (let ((val (dsssl-eval (pop args))))
  122.        (if val
  123.            (dsssl-eval (nth 0 args))
  124.          (if (nth 1 args)
  125.          (dsssl-eval (nth 1 args))))))
  126.     (let                ; FIXME
  127.      )
  128.     (case
  129.      (dsssl-min-args args 2)
  130.      (let* ((val (dsssl-eval (pop args)))
  131.         (conditions args)
  132.         (done nil)
  133.         (possibles nil)
  134.         (cur nil))
  135.        (while (and conditions (not done))
  136.          (setq cur (pop conditions)
  137.            possibles (nth 0 cur))
  138.          (if (or (and (listp possibles)
  139.               (member val possibles))
  140.              (equal val possibles)
  141.              (memq possibles '(default otherwise)))
  142.          (setq done (dsssl-eval (nth 1 cur)))))
  143.        done))
  144.     (equal\?
  145.      (dsssl-check-args args 2)
  146.      (equal (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  147.     (null\?
  148.      (dsssl-check-args args 1)
  149.      (null (dsssl-eval (car args))))
  150.     (list\?
  151.      (dsssl-check-args args 1)
  152.      (listp (dsssl-eval (car args))))
  153.     (list
  154.      (mapcar 'dsssl-eval args))
  155.     (length
  156.      (dsssl-check-args args 1)
  157.      (length (dsssl-eval (car args))))
  158.     (append
  159.      (apply 'append (mapcar 'dsssl-eval args)))
  160.     (reverse
  161.      (dsssl-check-args args 1)
  162.      (reverse (dsssl-eval (car args))))
  163.     (list-tail
  164.      (dsssl-check-args args 2)
  165.      (nthcdr (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  166.     (list-ref
  167.      (dsssl-check-args args 2)
  168.      (nth (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  169.     (member
  170.      (dsssl-check-args args 2)
  171.      (member (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  172.     (symbol\?
  173.      (dsssl-check-args args 1)
  174.      (symbolp (dsssl-eval (car args))))
  175.     (keyword\?
  176.      (dsssl-check-args args 1)
  177.      (keywordp (dsssl-eval (car args))))
  178.     (quantity\?
  179.      (dsssl-check-args args 1)
  180.      (error "%s not implemented yet." func))
  181.     (number\?
  182.      (dsssl-check-args args 1)
  183.      (numberp (dsssl-eval (car args))))
  184.     (real\?
  185.      (dsssl-check-args args 1)
  186.      (let ((rval (dsssl-eval (car args))))
  187.        (and (numberp rval)
  188.         (/= (truncate rval) rval))))
  189.     (integer\?
  190.      (dsssl-check-args args 1)
  191.      (let ((rval (dsssl-eval (car args))))
  192.        (and (numberp rval)
  193.         (= (truncate rval) rval))))
  194.     ((= < > <= >=)
  195.      (dsssl-min-args args 2)
  196.      (let ((not-done t)
  197.            (initial (dsssl-eval (car args)))
  198.            (next nil))
  199.        (setq args (cdr args))
  200.        (while (and args not-done)
  201.          (setq next (dsssl-eval (car args))
  202.            args (cdr args)
  203.            not-done (funcall func initial next)
  204.            initial next))
  205.        not-done))
  206.     ((+ *)
  207.      (dsssl-min-args args 2)
  208.      (let ((acc (dsssl-eval (car args))))
  209.        (setq args (cdr args))
  210.        (while args
  211.          (setq acc (funcall func acc (dsssl-eval (car args)))
  212.            args (cdr args)))
  213.        acc))
  214.     (-
  215.      (dsssl-min-args args 1)
  216.      (apply func (mapcar 'dsssl-eval args)))
  217.     (/
  218.      (dsssl-min-args args 1)
  219.      (if (= (length args) 1)
  220.          (/ 1 (dsssl-eval (car args)))
  221.        (apply func (mapcar 'dsssl-eval args))))
  222.     ((max min)
  223.      (apply func (mapcar 'dsssl-eval args)))
  224.     (abs
  225.      (dsssl-check-args args 1)
  226.      (abs (dsssl-eval (car args))))
  227.     (quotient            ; FIXME
  228.      (error "`%s' not implemented yet!" func))
  229.     (modulo
  230.      (dsssl-check-args args 2)
  231.      (mod (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  232.     (remainder
  233.      (dsssl-check-args args 2)
  234.      (% (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  235.     ((floor ceiling truncate round)
  236.      (dsssl-check-args args 1)
  237.      (funcall func (dsssl-eval (car args))))
  238.     (number->string
  239.      (dsssl-min-args args 1)
  240.      (if (= (length args) 1)
  241.          (number-to-string (dsssl-eval (car args)))
  242.        (if (= (length args) 2)    ; They gave us a radix
  243.            (error "Radix arg not supported yet.")
  244.          (dsssl-check-args args 1))))
  245.     (string->number
  246.      (dsssl-min-args args 1)
  247.      (if (= (length args) 1)
  248.          (string-to-number (dsssl-eval (car args)))
  249.        (if (= (length args) 2)    ; They gave us a radix
  250.            (error "Radix arg not supported yet.")
  251.          (dsssl-check-args args 1))))
  252.     (char\?
  253.      (dsssl-check-args args 1)
  254.      (characterp (dsssl-eval (car args))))
  255.     (char=\?
  256.      (dsssl-check-args args 2)
  257.      (char-equal (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  258.     (char-downcase
  259.      (dsssl-check-args args 1)
  260.      (downcase (dsssl-eval (car args))))
  261.     (char-property            ; FIXME
  262.      (error "`%s' not implemented yet!" func))
  263.     (string\?
  264.      (dsssl-check-args args 1)
  265.      (stringp (dsssl-eval (car args))))
  266.     (string
  267.      (dsssl-min-args args 1)
  268.      (mapconcat 'char-to-string (mapcar 'dsssl-eval args) ""))
  269.     (string-length
  270.      (dsssl-check-args args 1)
  271.      (length (dsssl-eval (car args))))
  272.     (string-ref
  273.      (dsssl-check-args args 2)
  274.      (aref (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  275.     (string=\?
  276.      (dsssl-check-args args 2)
  277.      (string= (dsssl-eval (car args)) (dsssl-eval (cadr args))))
  278.     (substring
  279.      (substring (dsssl-eval (pop args))
  280.             (dsssl-eval (pop args))
  281.             (dsssl-eval (pop args))))
  282.     (string-append
  283.      (let ((rval ""))
  284.        (while args
  285.          (setq rval (concat rval (dsssl-eval (pop args)))))
  286.        rval))
  287.     (procedure\?
  288.      (dsssl-check-args args 1)
  289.      (let* ((sym (dsssl-eval (car args)))
  290.         (def (cl-gethash sym defines)))
  291.        (or (memq sym dsssl-builtin-functions)
  292.            (and def (listp def) (eq (car def) 'lambda)))))
  293.     (apply                ; FIXME
  294.      )
  295.     (external-procedure        ; FIXME
  296.      )
  297.     (make
  298.      (let* ((type (dsssl-eval (pop args)))
  299.         (symname nil)
  300.         (props nil)
  301.         (tail nil)
  302.         (children nil)
  303.         (temp nil)
  304.         )
  305.        ;; Massage :children into the last slot
  306.        (setq props (mapcar 'dsssl-eval args)
  307.          tail (last props)
  308.          children (car tail))
  309.        (if (consp tail) 
  310.            (setcar tail nil))
  311.        (if (not (car props))
  312.            (setq props nil))
  313.        (setq temp (- (length props) 1))
  314.        ;; Not sure if we should really bother with this or not, but
  315.        ;; it does at least make it look more common-lispy keywordish
  316.        ;; and such.  DSSSL keywords look like font-weight:, this makes
  317.        ;; it :font-weight
  318.        (while (>= temp 0)
  319.          (setq symname (symbol-name (nth temp props)))
  320.          (if (string-match "^\\(.*\\):$" symname)
  321.          (setf (nth temp props) 
  322.                (intern (concat ":" (match-string 1 symname)))))
  323.          (setq temp (- temp 2)))
  324.  
  325.        ;; Create the actual flow object
  326.        (make-flow-object :type type
  327.                  :children children
  328.                  :properties props)
  329.        )
  330.      )
  331.     (time
  332.      (mapconcat 'int-to-string (current-time) ":"))
  333.     (time->string
  334.      (dsssl-check-args args 1)
  335.      (current-time-string
  336.       (mapcar 'string-to-int
  337.           (split-string (dsssl-eval (car args)) ":"))))
  338.     (quote
  339.      (dsssl-check-args args 1)
  340.      (car args))
  341.     (identity
  342.      (dsssl-check-args args 1)
  343.      (dsssl-eval (car args)))
  344.     (error
  345.      (apply 'error (mapcar 'dsssl-eval args)))
  346.     (otherwise
  347.      ;; A non-built-in function - look it up
  348.      (let ((def (cl-gethash func defines)))
  349.        (if (and def (listp def) (eq (car def) 'lambda))
  350.            (dsssl-call-function def args)
  351.          (error "Symbol's function definition is void: %s" func))))
  352.     )
  353.       )
  354.     )
  355.    ((symbolp form)            ; A variable
  356.     ;; A DSSSL keyword!
  357.     (if (string-match ":$" (symbol-name form))
  358.     form
  359.       (let ((val (cl-gethash form defines 'ThIS-Is_A_BOgUs-VariuhhBBLE)))
  360.     (if (not (eq val 'ThIS-Is_A_BOgUs-VariuhhBBLE))
  361.         val
  362.       ;; Ok, we got a bogus variable, but maybe it is really a UNIT
  363.       ;; dereference.  Check.
  364.       (let ((name (symbol-name form))
  365.         (the-units nil)
  366.         (number nil)
  367.         (conversion nil))
  368.         (if (not (string-match "^\\([0-9.]+\\)\\([a-zA-Z]+\\)$" name))
  369.         (error "Symbol's value as variable is void: %s" form)
  370.           (setq number (string-to-int (match-string 1 name))
  371.             the-units  (intern (downcase (match-string 2 name)))
  372.             conversion (cl-gethash the-units units))
  373.           (if (or (not conversion) (not (numberp conversion)))
  374.           (error "Symbol's value as variable is void: %s" form)
  375.         (* number conversion))))))))
  376.    (t
  377.     form)
  378.    )
  379.   )
  380.  
  381. (defsubst dsssl-predeclared ()
  382.   (declare (special defines units))
  383.   (cl-puthash '\#f nil defines)
  384.   (cl-puthash 'nil nil defines)
  385.   (cl-puthash '\#t t defines)
  386.   ;; NOTE: All units are stored internally as points.
  387.   (cl-puthash 'in (float 72) units)
  388.   (cl-puthash 'mm (float (* 72 25.4)) units)
  389.   (cl-puthash 'cm (float (* 72 2.54)) units)
  390.   )
  391.  
  392. (defun dsssl-parse (buf)
  393.   ;; Return the full representation of the DSSSL stylesheet as a series
  394.   ;; of LISP objects.
  395.   (let ((defines (make-hash-table :size 13))
  396.     (units   (make-hash-table :size 13))
  397.     (buf-contents nil))
  398.     (dsssl-predeclared)
  399.     (save-excursion
  400.       (setq buf-contents (if (or (bufferp buf) (get-buffer buf))
  401.                  (progn
  402.                    (set-buffer buf)
  403.                    (buffer-string))
  404.                buf))
  405.       (set-buffer (generate-new-buffer " *dsssl-style*"))
  406.       (insert buf-contents)
  407.       (goto-char (point-min))
  408.       (skip-chars-forward " \t\n\r")
  409.       (if (looking-at "<!")        ; DOCTYPE present
  410.       (progn
  411.         ;; This should _DEFINITELY_ be smarter
  412.         (search-forward ">" nil t)
  413.         ))
  414.       (let ((result nil)
  415.         (temp nil)
  416.         (save-pos nil))
  417.     (while (not (eobp))
  418.       (condition-case ()
  419.           (setq save-pos (point)
  420.             temp (read (current-buffer)))
  421.         (invalid-read-syntax
  422.          ;; This disgusting hack is in here so that we can basically
  423.          ;; extend the lisp reader to gracefully deal with converting
  424.          ;; DSSSL #\A to Emacs-Lisp ?A notation.  If you know of a
  425.          ;; better way, please feel free to send me some email.
  426.          (setq temp nil)
  427.          (backward-char 1)
  428.          (if (looking-at "#\\\\")
  429.          (replace-match "?")
  430.            (insert "\\"))
  431.          (goto-char save-pos))
  432.         (error nil))
  433.       (cond
  434.        ((null temp)
  435.         nil)
  436.        ((listp temp)
  437.         (case (car temp)
  438.           (define-unit
  439.             (cl-puthash (cadr temp) (dsssl-eval (caddr temp))
  440.                 units))
  441.           (define
  442.             (if (listp (cadr temp))
  443.             ;; A function
  444.             (cl-puthash (caadr temp)
  445.                      (list 'lambda
  446.                        (cdadr temp)
  447.                        (cddr temp)) defines)
  448.               ;; A normal define
  449.               (cl-puthash (cadr temp)
  450.                    (dsssl-eval (caddr temp)) defines)))
  451.           (otherwise
  452.            (setq result (cons temp result)))))
  453.        (t
  454.         (setq result (cons temp result))))
  455.       (skip-chars-forward " \t\n\r"))
  456.     (kill-buffer (current-buffer))
  457.     (list defines units (nreverse result))))))
  458.  
  459. (defun dsssl-test (x)
  460.   (let* ((result (dsssl-parse x))
  461.      (defines (nth 0 result))
  462.      (units   (nth 1 result))
  463.      (forms   (nth 2 result)))
  464.     (mapcar 'dsssl-eval forms)))
  465.  
  466.  
  467. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  468. ;;; The flow object classes.
  469. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  470. (defmacro flow-object-property (obj prop &optional default)
  471.   "Return property PROP of the DSSSL flow object OBJ.
  472. OBJ can be any flow object class, as long as it was properly derived
  473. from the base `flow-object' class."
  474.   (` (plist-get (flow-object-properties (, obj)) (, prop) (, default))))
  475.  
  476. ;; Now for specific types of flow objects
  477. ;; Still to do:
  478. ;;; display-group
  479. ;;; paragraph
  480. ;;; sequence
  481. ;;; line-field
  482. ;;; paragraph-break
  483. ;;; simple-page-sequence
  484. ;;; score
  485. ;;; table
  486. ;;; table-row
  487. ;;; table-cell
  488. ;;; rule
  489. ;;; external-graphic
  490.  
  491.  
  492. (provide 'dsssl)
  493.